home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlispsrc.arc / XLSYS.C < prev   
C/C++ Source or Header  |  1988-02-11  |  3KB  |  162 lines
  1. /* xlsys.c - xlisp builtin system functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern jmp_buf top_level;
  10. extern FILE *tfp;
  11.  
  12. /* external symbols */
  13. extern LVAL a_subr,a_fsubr,a_cons,a_symbol;
  14. extern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream;
  15. extern LVAL a_vector,a_closure,a_char,a_ustream;
  16. extern LVAL k_verbose,k_print;
  17. extern LVAL true;
  18.  
  19. /* external routines */
  20. extern FILE *osaopen();
  21.  
  22. /* xload - read and evaluate expressions from a file */
  23. LVAL xload()
  24. {
  25.     unsigned char *name;
  26.     int vflag,pflag;
  27.     LVAL arg;
  28.  
  29.     /* get the file name */
  30.     name = getstring(xlgetfname());
  31.  
  32.     /* get the :verbose flag */
  33.     if (xlgetkeyarg(k_verbose,&arg))
  34.     vflag = (arg != NIL);
  35.     else
  36.     vflag = TRUE;
  37.  
  38.     /* get the :print flag */
  39.     if (xlgetkeyarg(k_print,&arg))
  40.     pflag = (arg != NIL);
  41.     else
  42.     pflag = FALSE;
  43.  
  44.     /* load the file */
  45.     return (xlload(name,vflag,pflag) ? true : NIL);
  46. }
  47.  
  48. /* xtranscript - open or close a transcript file */
  49. LVAL xtranscript()
  50. {
  51.     unsigned char *name;
  52.  
  53.     /* get the transcript file name */
  54.     name = (moreargs() ? getstring(xlgetfname()) : NULL);
  55.     xllastarg();
  56.  
  57.     /* close the current transcript */
  58.     if (tfp) osclose(tfp);
  59.  
  60.     /* open the new transcript */
  61.     tfp = (name ? osaopen(name,"w") : NULL);
  62.  
  63.     /* return T if a transcript is open, NIL otherwise */
  64.     return (tfp ? true : NIL);
  65. }
  66.  
  67. /* xtype - return type of a thing */
  68. LVAL xtype()
  69. {
  70.     LVAL arg;
  71.  
  72.     if (!(arg = xlgetarg()))
  73.     return (NIL);
  74.  
  75.     switch (ntype(arg)) {
  76.     case SUBR:        return (a_subr);
  77.     case FSUBR:        return (a_fsubr);
  78.     case CONS:        return (a_cons);
  79.     case SYMBOL:    return (a_symbol);
  80.     case FIXNUM:    return (a_fixnum);
  81.     case FLONUM:    return (a_flonum);
  82.     case STRING:    return (a_string);
  83.     case OBJECT:    return (a_object);
  84.     case STREAM:    return (a_stream);
  85.     case VECTOR:    return (a_vector);
  86.     case CLOSURE:    return (a_closure);
  87.     case CHAR:        return (a_char);
  88.     case USTREAM:    return (a_ustream);
  89.     default:        xlfail("bad node type");
  90.     }
  91. }
  92.  
  93. /* xbaktrace - print the trace back stack */
  94. LVAL xbaktrace()
  95. {
  96.     LVAL num;
  97.     int n;
  98.  
  99.     if (moreargs()) {
  100.     num = xlgafixnum();
  101.     n = getfixnum(num);
  102.     }
  103.     else
  104.     n = -1;
  105.     xllastarg();
  106.     xlbaktrace(n);
  107.     return (NIL);
  108. }
  109.  
  110. /* xexit - get out of xlisp */
  111. LVAL xexit()
  112. {
  113.     xllastarg();
  114.     wrapup();
  115. }
  116.  
  117. /* xpeek - peek at a location in memory */
  118. LVAL xpeek()
  119. {
  120.     LVAL num;
  121.     int *adr;
  122.  
  123.     /* get the address */
  124.     num = xlgafixnum(); adr = (int *)getfixnum(num);
  125.     xllastarg();
  126.  
  127.     /* return the value at that address */
  128.     return (cvfixnum((FIXTYPE)*adr));
  129. }
  130.  
  131. /* xpoke - poke a value into memory */
  132. LVAL xpoke()
  133. {
  134.     LVAL val;
  135.     int *adr;
  136.  
  137.     /* get the address and the new value */
  138.     val = xlgafixnum(); adr = (int *)getfixnum(val);
  139.     val = xlgafixnum();
  140.     xllastarg();
  141.  
  142.     /* store the new value */
  143.     *adr = (int)getfixnum(val);
  144.  
  145.     /* return the new value */
  146.     return (val);
  147. }
  148.  
  149. /* xaddrs - get the address of an XLISP node */
  150. LVAL xaddrs()
  151. {
  152.     LVAL val;
  153.  
  154.     /* get the node */
  155.     val = xlgetarg();
  156.     xllastarg();
  157.  
  158.     /* return the address of the node */
  159.     return (cvfixnum((FIXTYPE)val));
  160. }
  161.  
  162.